home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d27 / bu4dir.arc / BU4DIR.PAS < prev    next >
Pascal/Delphi Source File  |  1990-06-14  |  7KB  |  282 lines
  1. Program BU4DIR(Input, Output);
  2.  
  3. Uses Dos;
  4.  
  5. Const
  6.     Maxlinelength        = 80;
  7.     Maxpath              = 63;
  8.     test0                = false;
  9.     test1                = false;
  10.  
  11.     {$I-}
  12.  
  13. Type LineType            = Packed Array[1..Maxlinelength] of char;
  14.      LengthType          = 0..Maxlinelength;
  15.      Pathtype            = String[maxpath];
  16.      String2             = String[2];
  17.      String3             = Packed Array[1..3] of char;
  18.      String8             = Packed Array[1..8] of char;
  19.      String12            = Packed Array[1..12] of char;
  20.      String15            = String[15];
  21.  
  22. Var
  23.      position            : Longint;
  24.      ch, eoname          : char;
  25.      disknumber,
  26.      startdisk           : word;
  27.      path                : pathtype;
  28.      pathctr, length     : byte;
  29.      filename            : String12;
  30.      filesize,
  31.      sizethisdisk,
  32.      fileoffset,
  33.      filedate            : longint;
  34.      fileattr            : word;
  35.      infile              : file;
  36.      infdt, filedt       : datetime;
  37.      infdatestring       : String8;
  38.      outfile             : text;
  39.      filein              : String15;
  40.      Drive               : String2;
  41.      dirinfo             : Searchrec;
  42.      Line                : LineType;
  43.      m1,m2,t             : char;
  44.      a,b,c,e,f,y         : byte;
  45.      fileoutput          : boolean;
  46. (******************************************************)
  47. PROCEDURE GETCHAR(VAR CHR: char);
  48. Begin
  49.   If not eof(infile) then
  50.     begin
  51.       Blockread(infile,chr,1);
  52.       inc(position);
  53.       dec(length);
  54.     end;
  55. End;
  56. (******************************************************)
  57. PROCEDURE BreadWord(VAR buf: word);
  58. Begin
  59.   If not eof(infile) then
  60.   begin
  61.     Blockread(infile,buf,2);
  62.     inc(position,2);
  63.     dec(length,2);
  64.   end;
  65. End;
  66. (******************************************************)
  67. PROCEDURE BreadLongint(VAR buf: longint);
  68. Begin
  69.   If not eof(infile) then
  70.   begin
  71.     Blockread(infile,buf,4);
  72.     inc(position,4);
  73.     dec(length,4);
  74.   end;
  75. End;
  76. (*****************************************************)
  77. Procedure ClearPath;
  78. Var p : byte;
  79. Begin
  80.   for p := 1 to maxpath DO path[p] := ' ';
  81. End;
  82. (*****************************************************)
  83. Procedure Clearname;
  84. Var p : byte;
  85. Begin
  86.   for p := 1 to 12 DO filename[p] := ' ';
  87. End;
  88. (*****************************************************)
  89. Procedure WritePath;
  90. Var p : byte;
  91.     forty : boolean;
  92. Begin
  93.   Write('\');
  94.   if pathctr > 39 then forty := true else forty := false;
  95.   if pathctr > 0 then
  96.   Begin
  97.   for p := 1 to pathctr DO
  98.     begin
  99.       Write(path[p]);
  100.       if (p > 27) and forty and (path[p] = '\') then
  101.         begin
  102.           Writeln;
  103.           Write('':41);
  104.           forty := false;
  105.         end;
  106.     end;
  107.   Write('\');
  108.   End;
  109. End;
  110. (*****************************************************)
  111. Procedure WriteName;
  112. Var p, q, r : byte;
  113. Begin
  114.   p := 0;
  115.   r := 0;
  116.   While r < 12 DO
  117.   Begin
  118.     inc(p);
  119.     if (filename[p] = '.')
  120.       then For q := p to 9 do
  121.            begin
  122.              write(' ');
  123.              inc(r);
  124.            end
  125.       else begin
  126.              write(filename[p]);
  127.              inc(r);
  128.            end;
  129.   End;
  130. End;
  131. (*****************************************************)
  132. Procedure Writedate(d : datetime);
  133. Begin
  134.   If d.month > 9 then Write(d.month,'-') else Write('0',d.month,'-');
  135.   If d.day > 9 then Write(d.day) else Write('0',d.day);
  136.   Write('-',(infdt.year mod 100),'  ');
  137.   Write((d.hour mod 12):2,':');
  138.   If d.min > 9 then Write(d.min) else Write('0',d.min);
  139.   If d.hour > 12 then Write('p') else Write('a');
  140. End;
  141. (*****************************************************)
  142. Procedure Writeline;
  143. Begin
  144.   Writename;
  145.   Write(filesize:10);
  146.   Write(' ');
  147.   Writedate(filedt);
  148.   Write(' ');
  149.   WritePath;
  150.   Writeln;
  151. End;
  152. (****************************************************)
  153. PROCEDURE GetPath;
  154. Begin
  155.   Clearpath;
  156.   length := ord(ch);
  157.   pathctr := 0;
  158.   getchar(ch);
  159.   While (ord(ch) >  32) and (ord(ch) <= 126) Do
  160.   Begin
  161.     inc(pathctr);
  162.     path[pathctr] := ch;
  163.     getchar(ch);
  164.   End;
  165.   While length > 0 do Getchar(ch);
  166.   {
  167.   Writeln;
  168.   WritePath;
  169.   Writeln;
  170.   }
  171. End;
  172. (****************************************************)
  173. PROCEDURE GetName;
  174. Begin
  175.   if ord(ch)<>34 then Writeln('File info length <> 34, is ',ord(ch));
  176.   Blockread(infile,filename,sizeof(filename));
  177.   inc(position,12);
  178.   dec(length,12);
  179. End;
  180. (****************************************************)
  181. PROCEDURE GetFile;
  182. Var z : byte;
  183. Begin
  184.   length := ord(ch);
  185.   Getname;
  186.   Getchar(eoname);
  187.   Breadlongint(filesize);
  188.   BreadWord(startdisk);
  189.   Breadlongint(fileoffset);
  190.   Breadlongint(sizethisdisk);
  191.   BreadWord(fileattr);
  192.   BreadLongint(filedate);
  193.   While length > 0 do if not eof(infile) then Getchar(ch) else dec(length);
  194. End;
  195. (****************************************************)
  196. PROCEDURE GetDiskNumber;
  197. Var z : byte;
  198. Begin
  199.   length := 1;
  200.   Getchar(ch);
  201.   length := ord(ch);
  202.   For z:= 2 to 9 Do Getchar(ch);
  203.   BreadWord(disknumber);
  204.   While length > 0 do Getchar(ch);
  205.   Writeln('Directory of Backup Disk ',Disknumber);
  206.   Write('Files backed up ');
  207.   Writedate(infdt);
  208.   Writeln;
  209.   Writeln;
  210. End;
  211. (*****************************************************)
  212. Procedure Listdir(Var controlname: String15);
  213. Begin
  214.    Writeln;
  215.    GetDiskNumber;
  216.    While not eof(infile) Do
  217.    begin
  218.      If ord(ch) > 40 then Getpath else
  219.      begin
  220.        GetFile;
  221.        unpacktime(filedate,filedt);
  222.        Writeline;
  223.      end;
  224.    end;
  225.    Writeln;
  226. End;
  227. (*****************************************************)
  228. Procedure GetInfile;
  229. Var y: integer;
  230.     ss : string2;
  231. Begin
  232.   drive := paramstr(1);
  233.   if pos(':',drive) = 0 then drive := drive + ':';
  234.   filein := drive + '\' + 'CONTROL.*';
  235.   findfirst(filein,$21,dirinfo);
  236.   filein := drive+dirinfo.name;
  237.   assign(infile,filein);
  238.   SetFattr(infile, 0);
  239.   Reset(infile,1);
  240.   Unpacktime(dirinfo.time, infdt);
  241. End;
  242. (*****************************************************)
  243. Procedure CloseInfile;
  244. Begin
  245.   close(infile);
  246.   SetFattr(infile, dirinfo.attr);
  247. End;
  248. (*****************************************************)
  249. Procedure NoParms;
  250. Begin
  251.   Writeln;
  252.   writeln('BU4DIR Version 1.0  (C) Curt Freeman 6-14-90');
  253.   Writeln('USAGE: BU4DIR d:');
  254.   Writeln('Gives dir of Dos 4.0x Backup disk from Control.nnn file');
  255.   Writeln;
  256.   halt(0);
  257. end;
  258. (*****************************************************)
  259. Procedure TwoParms;
  260. begin
  261.   assign(outfile,paramstr(2));
  262.   Rewrite(Outfile);
  263.   fileoutput := true;
  264. end;
  265. (*****************************************************)
  266. Procedure Initialize;
  267. Begin
  268.   position := 0;
  269. End;
  270. (*****************************************************)
  271. BEGIN   {MAIN}
  272. if paramcount < 1 then NoParms;
  273. if paramcount > 1 then TwoParms;
  274. Initialize;
  275. Getinfile;
  276. if Doserror = 0 then
  277. begin
  278.   listdir(filein);
  279. end;
  280. halt(0);
  281. end.
  282.